(load "st-utility.lisp")
(load "3turple.lisp")


(define (读其他 c) nil)
(define (读任意字符 c) t)
(define 剩余字串 '(subseq s i (length s)))
(define 全部字串 's)

(define (返回值转换 st res)
    (cond ((null res) nil)
	  ((atom res)
	   (cond ((eql st '始) res)
		 (t (list res st))))
	  ((consp res)
	   (cond ((eql st '始) res)
		 (t (concatenate 'list res (list st)))))))
(define (返回值回送  res) (if (atom res) res (if (consp res) (car res))))
(define (返回值扩展  res) res)		 
		 

(define (:macro sset+ a b) `(setf ,a (concatenate 'string ,a ,b)))
(define (:macro sset+s a b) `(setf ,a (concatenate 'string ,a (format nil "~a" ,b))))
(define (:macro sset+l a b) `(setf ,a (concatenate 'list ,a ,b)))

;;name-list NOT ALLOWED has c var!!!
;;name-list NOT ALLOWED has c var!!!
;;name-list NOT ALLOWED has c var!!!

(define (st-program-all-par l name-list typ fn res-type &optional test-flag)
    (let ((s (cadr name-list))(nl nil)(name (car name-list)))
      (setf prefix (string (car name-list)))
  
      (sset+ nl (format nil "(define ~a " name-list))
      (sset+ nl "(let ((st '始)(c nil)(nl nil)(res nil))")
      (sset+ nl (format nil "(block tr-str (travel ~a 'for-index i (setf c (~a ~a i)) " s fn s))
      (if test-flag (progn (sset+ nl (format nil "(format t \"~a" name))(sset+ nl "[~a][~a]~%\"  st c)")))
 
      (cond ((null typ) (sset+ nl (get-condition-exec name 'c l)))
	    ((eql typ 'status) (sset+ nl (get-status-cond name 'c l res-type)))
	    ((eql typ 'act) (sset+ nl (get-act-cond name 'c l res-type )))
	    (t (format t "illegal type[~a] at st-program call.~%" typ)))
      (sset+ nl (get-res-cond l res-type name test-flag))))
(define (st-program l name-list)
    (let ((s (cadr name-list))(nl nil))
      (setf prefix (string (car name-list)))
      (sset+ nl (format nil "(define ~a " name-list))
      (sset+ nl "(let ((st '始)(c nil)(nl nil))")
      (sset+ nl (format nil "(block tr-str (travel ~a 'for-index i (setf c (elt ~a i)) " s s))
      (sset+ nl (get-condition-exec prefix 'c l))
      (sset+ nl (get-res-cond l))))
(define (get-condition-exec prefix c l)
    (if (< (length (status-chain l)) (length (act-chain l)))
	(get-status-cond prefix c l)
	(get-act-cond prefix c l)))
(define (get-act-cond name c l &optional ft )
    (let ((nl nil)(act-fn nil)(act-c nil)(end-flag nil)(other-flag nil))
      (sset+ nl "(cond ")
      (travel  (act-chain l) 'for-child i
	      
	      
	       (if (eql i '读其他)
		   (setf other-flag 1)
		   (progn  (if (and (consp i)(cadr i))
			       (progn (setf act-fn (car i))(setf act-c (eval (cadr i)))(sset+ nl (format nil "((setf res (~a ~a))" act-fn act-c)))
			       (progn (sset+ nl (format nil "((~a ~a) " i 'c))
				      (if (and (= (length (act-in-chain i l)) 1)(eql (nth 2 (car (act-in-chain i l))) '终))
					  (sset+ nl ")")
					  (progn (sset+ nl "(cond ")
						 (travel (act-in-chain i l) 'for-child j
							 (cond ((eql (nth 2 j) '终) (setf end-flag 1))
							       ((eql (nth 2 j) '返回值) (sset+ nl (format nil "((eql st '~a) (setf res (返回值转换 res st) (setf st '返回值)(return-from tr-str st))" (car j))))
							       (t   (sset+ nl (format nil "((eql st '~a)" (car j)))
								    (cond ((null ft) nil)
									  ((eql ft 'log) nil)
									  ((eql ft 'str) (sset+ nl (format nil "(sset+ nl (string ~a))" c)))
									  ((eql ft 'list)(sset+ nl (format nil "(sset+l nl ~a)" (if (consp c) c '(list c)))))
									  (t (sset+ nl (format nil "(apply ~a nl ~a) " ft c))))
								    (sset+ nl (format nil "(setf st '~a))" (nth 2 j))))))
						 (sset+ nl (format nil "(t (return-from ~a nil))))" name)))))))))
      (sset+ nl (format nil "(t (return-from ~a nil)))))" name))))
(define (get-res-cond l &optional ft name test-flag)
    (let ((nl nil)(res-method nil))
	  
      (if test-flag (progn (sset+ nl (format nil "(format t \"~a" name))(sset+ nl "<st=\~a><res=\~a>~%\" st res)")))
      (sset+ nl "(if ")
      (if (= (length (in-chain '终 l)) 1)
	  (if (eql (car (car (in-chain '终 l))) '返回值)
	      (progn (sset+ nl "(eql st '返回值) ")
				     (cond ((or (null ft) (eql ft 'log)) (sset+ nl (format nil "(~a res) nil)))" (cadr (car (in-chain '终 l))))))
					   (t (sset+ nl "nl nil)))"))))
	      (progn  (sset+ nl (format nil "(eql st '~a)" (car (car (in-chain '终 l)))))
		      (cond ((or (null ft) (eql ft 'log)) (sset+ nl " st "))
			    (t (sset+ nl " nl ")))
		      (sset+ nl "nil )))")))
	  (progn (sset+ nl "(or ")
		 (travel (in-chain '终 l) 'for-child i
			 (if (eql (car i) '返回值) (setf res-method (cadr i))
			     (sset+ nl (format nil "(eql st '~a)" (car i)))))
		 (cond ((or (null ft) (eql ft 'log)) (sset+ nl ") st "))
		       (t (sset+ nl ") nl ")))
		 (if res-method (progn (sset+ nl "(if (eql st '返回值) ")
				     (cond ((or (null ft) (eql ft 'log)) (sset+ nl (format nil "(~a res) nil))))" res-method )))
					   (t (sset+ nl "nl nil))))"))))
		     (sset+ nl "nil )))"))))))
	  
		    
(define (get-status-cond name c l &optional ft)
    (let ((nl nil)(act-fn nil)(act-c nil)(end-flag nil)(other-flag nil))
      (sset+ nl "(cond ")
      (travel  (status-chain l) 'for-child i
	       (cond ((eql i '终) (setf end-flag 1))
		     ((eql i '返回值) (setf end-flag 1))
		     (t (progn (sset+ nl (format nil "((eql st '~a) " i))
			       (if (and (= (length (out-chain i l)) 1)(eql (nth 2 (car (out-chain i l))) '终))
				   (sset+ nl "st )")
				   (progn (sset+ nl "(cond ")
					  (travel (out-chain i l) 'for-child j
						  (if (and (consp (cadr j))(cadr (cadr j)))
						      (progn (setf act-fn  (format nil "~a" (car (cadr j))))
							     (setf act-c (eval (cadr (cadr j)))))
						      (progn (setf act-fn (cadr j))
							     (setf act-c 'c)))
						  (cond  ((eql (cadr j) '读其他)  (setf other-flag 1))
							 ((and (consp (cadr j))(eql (nth 2 j) '返回值))(sset+ nl (format nil "((setf res (~a ~a)) (setf res (返回值转换 st res))(setf st '返回值)(return-from tr-str st))" act-fn act-c)))
							 (t (sset+ nl (format nil "((~a ~a) " (cadr j) 'c))
							    (cond
							      ((null ft) nil)
							      ((eql ft 'log)nil)
							      ((eql ft 'str) (sset+ nl (format nil "(sset+ nl (string ~a))" c)))
							      ((eql ft 'list) (sset+ nl (format nil "(sset+l nl ~a)" (if (consp c) c (list c)))))
							      (t (sset+ nl (format nil "(apply ~a nl ~a) " ft c))))
							    (sset+ nl (format nil "(setf st '~a))" (nth 2 j))))))
					  (sset+ nl (format nil "(t (return-from ~a nil))))" name))))))))
      (sset+ nl (format nil "(t (return-from ~a nil)))))" name))))

(define (create-st f &optional test-flag)
    (let ((ll nil)(r nil))
    (setf ll (read-st-file f))
  ;(default-act-func (act-chain ll))
  ;(setf r (chain-check ll))
  (if (null r) (progn   (setf l (read-from-string
				 (if test-flag
				     (st-program-all-par ll (list f 's) 'status 'elt 'log 'test)
				     (st-program-all-par ll (list f 's) 'status 'elt 'log))))
			(eval l)
			(write-list l (format nil "~a.lisp" f))
			(setf example-list nil))
      (format t "[~a.st] file has error,please check it:~%~a" f r))))
(define (test-st f )  
  ;(load "def.lisp")
  (read-example-list f)
  (_test f))

  
		 


								    
	      















    
